home *** CD-ROM | disk | FTP | other *** search
/ Delphi Informant Complete 1995 - 2000 / Delphi Informant Complete 1995 to 2000.iso / Delphi Informant Magazine Complete Works SOURCE CODE 1998.rar / 1998 / Feb / di9802kw / WebPics1.pas < prev    next >
Pascal/Delphi Source File  |  1997-08-19  |  11KB  |  363 lines
  1. unit WebPics1;
  2.  
  3. {
  4.   Extract a picture from a database and display it on the web.
  5.  
  6.   Written by Keith Wood, 12 Aug 1997.
  7. }
  8.  
  9. interface
  10.  
  11. uses
  12.   Windows, Messages, SysUtils, Classes, HTTPApp, Db, DBTables, Registry;
  13.  
  14. type
  15.   TwmdWebPics = class(TWebModule)
  16.     qryWebPics: TQuery;
  17.     dbsWebPics: TDatabase;
  18.     wppListSchemes: TPageProducer;
  19.     wppAddScheme: TPageProducer;
  20.     wppUpdateScheme: TPageProducer;
  21.     procedure wmdWebPicsCreate(Sender: TObject);
  22.     procedure wmdWebPicsDestroy(Sender: TObject);
  23.     procedure wmdWebPicswacGetPicAction(Sender: TObject;
  24.       Request: TWebRequest; Response: TWebResponse; var Handled: Boolean);
  25.     procedure wmdWebPicswacConfigureAction(Sender: TObject;
  26.       Request: TWebRequest; Response: TWebResponse; var Handled: Boolean);
  27.     procedure wppListSchemesHTMLTag(Sender: TObject; Tag: TTag;
  28.       const TagString: String; TagParams: TStrings;
  29.       var ReplaceText: String);
  30.     procedure wppAddSchemeHTMLTag(Sender: TObject; Tag: TTag;
  31.       const TagString: String; TagParams: TStrings;
  32.       var ReplaceText: String);
  33.     procedure wppUpdateSchemeHTMLTag(Sender: TObject; Tag: TTag;
  34.       const TagString: String; TagParams: TStrings;
  35.       var ReplaceText: String);
  36.   private
  37.     { Private declarations }
  38.     slsHTTPFields: TStrings;
  39.     regSchemes: TRegistry;
  40.     sSchemeId: String;
  41.     sSchemeName: String;
  42.     sAliasName: String;
  43.     sUserId: String;
  44.     sPassword: String;
  45.     slsOtherParams: TStringList;
  46.     sTableName: String;
  47.     sKeyField: String;
  48.     sBlobField: String;
  49.     sTypeField: String;
  50.     procedure SetFields;
  51.     function LoadScheme(sId: String): Boolean;
  52.     function Coded(sPassword: String): String;
  53.     procedure DeleteScheme;
  54.     procedure AddScheme;
  55.     procedure UpdateScheme;
  56.     procedure SaveScheme(sSchemeId: String);
  57.   public
  58.     { Public declarations }
  59.   end;
  60.  
  61. var
  62.   wmdWebPics: TwmdWebPics;
  63.  
  64. implementation
  65.  
  66. {$R *.DFM}
  67.  
  68. const
  69.   sRegKey = '\Software\Kwood\WebPics';
  70.   sNameKey = 'SchemeName';
  71.   sAliasKey = 'AliasName';
  72.   sUserKey = 'UserId';
  73.   sPasswordKey = 'Password';
  74.   sOtherKey = 'OtherParams';
  75.   sTableKey = 'TableName';
  76.   sKeyKey = 'KeyField';
  77.   sBlobKey = 'BlobField';
  78.   sTypeKey = 'TypeField';
  79.  
  80. { Initialisation }
  81. procedure TwmdWebPics.wmdWebPicsCreate(Sender: TObject);
  82. begin
  83.   regSchemes := TRegistry.Create;
  84.   slsOtherParams := TStringList.Create;
  85. end;
  86.  
  87. { Free resources }
  88. procedure TwmdWebPics.wmdWebPicsDestroy(Sender: TObject);
  89. begin
  90.   regSchemes.Free;
  91.   slsOtherParams.Free;
  92. end;
  93.  
  94. { Set pointer to request fields depending on request method }
  95. procedure TwmdWebPics.SetFields;
  96. begin
  97.   if Request.MethodType = mtPost then
  98.     slsHTTPFields := Request.ContentFields
  99.   else
  100.     slsHTTPFields := Request.QueryFields;
  101. end;
  102.  
  103. { Load details about a scheme from the registry }
  104. function TwmdWebPics.LoadScheme(sId: String): Boolean;
  105. begin
  106.   Result := True;
  107.   with regSchemes do
  108.     try
  109.       if not OpenKey(sRegKey + '\' + sId, False) then
  110.         Abort;
  111.       sSchemeId := sId;
  112.       sSchemeName := ReadString(sNameKey);
  113.       sAliasName := ReadString(sAliasKey);
  114.       sUserId := ReadString(sUserKey);
  115.       sPassword := Coded(ReadString(sPasswordKey));
  116.       slsOtherParams.Text := ReadString(sOtherKey);
  117.       sTableName := ReadString(sTableKey);
  118.       sKeyField := ReadString(sKeyKey);
  119.       sBlobField := ReadString(sBlobKey);
  120.       sTypeField := ReadString(sTypeKey);
  121.     except
  122.       Result := False;
  123.     end;
  124. end;
  125.  
  126. { En/decode password field }
  127. function TwmdWebPics.Coded(sPassword: String): String;
  128. var
  129.   i: Integer;
  130. begin
  131.   Result := '';
  132.   for i := 1 to Length(sPassword) do
  133.     Result := Result + Chr(160 - Ord(sPassword[i]));
  134. end;
  135.  
  136. { Extract a picture from the database and return it }
  137. procedure TwmdWebPics.wmdWebPicswacGetPicAction(Sender: TObject;
  138.   Request: TWebRequest; Response: TWebResponse; var Handled: Boolean);
  139. var
  140.   sSelect: String;
  141.   stmHeader: TStringStream;
  142. begin
  143.   SetFields;
  144.   { Check for valid scheme }
  145.   if not LoadScheme(slsHTTPFields.Values['SCHEME']) then
  146.     Response.StatusCode := 400
  147.   else
  148.   begin
  149.     { Initialise database with scheme details }
  150.     with dbsWebPics do
  151.     begin
  152.       AliasName := sAliasName;
  153.       Params.Clear;
  154.       if sUserId <> '' then
  155.         Params.Add('username=' + sUserId);
  156.       if sPassword <> '' then
  157.         Params.Add('password=' + sPassword);
  158.       if slsOtherParams.Count > 0 then
  159.         Params.AddStrings(slsOtherParams);
  160.       Open;
  161.     end;
  162.     { Find the required record and extract the image }
  163.     with Response, qryWebPics do
  164.       try
  165.         sSelect := sBlobField;
  166.         if sTypeField <> '' then
  167.           sSelect := sSelect + ', ' + sTypeField;
  168.         SQL.Clear;
  169.         SQL.Add('select ' + sSelect);
  170.         SQL.Add('from ' + sTableName);
  171.         SQL.Add('where ' + sKeyField + ' = ' + slsHTTPFields.Values['ID']);
  172.         Open;
  173.         try
  174.           ContentStream := TBlobStream.Create(TBlobField(FieldByName(sBlobField)), bmRead);
  175.           { Set image type }
  176.           if sTypeField <> '' then
  177.             ContentType := FieldByName(sTypeField).AsString
  178.           else
  179.           begin
  180.             try
  181.               stmHeader := TStringStream.Create('');
  182.               stmHeader.CopyFrom(ContentStream, 0);
  183.               ContentStream.Position := 0;
  184.               if Pos('JFIF', Copy(stmHeader.DataString, 1, 10)) = 7 then
  185.                 ContentType := 'image/jpeg'
  186.               else if Pos('GIF', Copy(stmHeader.DataString, 1, 10)) = 1 then
  187.                 ContentType := 'image/gif';
  188.             finally
  189.               stmHeader.Free;
  190.             end;
  191.           end;
  192.         except
  193.           StatusCode := 500;
  194.         end;
  195.       except
  196.         StatusCode := 404;
  197.       end;
  198.   end;
  199. end;
  200.  
  201. { Configuration -------------------------------------------------------------- }
  202.  
  203. { Accept request and perform configuration actions }
  204. procedure TwmdWebPics.wmdWebPicswacConfigureAction(Sender: TObject;
  205.   Request: TWebRequest; Response: TWebResponse; var Handled: Boolean);
  206. var
  207.   sAction: String;
  208. begin
  209.   SetFields;
  210.   sAction := slsHTTPFields.Values['ACTION'];
  211.   { Display a single scheme's details }
  212.   if sAction = 'Get' then
  213.   begin
  214.     if slsHTTPFields.Values['ID'] = '0' then
  215.       Response.Content := wppAddScheme.Content
  216.     else if LoadScheme(slsHTTPFields.Values['ID']) then
  217.       Response.Content := wppUpdateScheme.Content
  218.     else
  219.       Response.StatusCode := 400;
  220.   end
  221.   else
  222.   { Apply changes to the registry (if applicable) and redisplay complete list }
  223.   begin
  224.     if sAction = 'Delete' then
  225.       DeleteScheme
  226.     else if sAction = 'Add' then
  227.       AddScheme
  228.     else if sAction = 'Update' then
  229.       UpdateScheme;
  230.     Response.Content := wppListSchemes.Content;
  231.   end;
  232. end;
  233.  
  234. { List all schemes }
  235. procedure TwmdWebPics.wppListSchemesHTMLTag(Sender: TObject; Tag: TTag;
  236.   const TagString: String; TagParams: TStrings; var ReplaceText: String);
  237. var
  238.   i: Integer;
  239.   slsKeys: TStringList;
  240. begin
  241.   if TagString = 'SCRIPT' then
  242.     ReplaceText := Request.ScriptName
  243.   else if TagString = 'SCHEMES' then
  244.   begin
  245.     ReplaceText := '<p>No configurations schemes currently registered.</p>';
  246.     with regSchemes do
  247.       if OpenKey(sRegKey, False) then
  248.       begin
  249.         slsKeys := TStringList.Create;
  250.         try
  251.           GetKeyNames(slsKeys);
  252.           if slsKeys.Count = 0 then
  253.             Exit;
  254.           ReplaceText := '<table width=100%>'#13#10;
  255.           for i := 0 to slsKeys.Count - 1 do
  256.             if LoadScheme(slsKeys[i]) then
  257.             begin
  258.               ReplaceText := ReplaceText + '<tr><td>' + sSchemeId + '<td><a href="' +
  259.                 Request.ScriptName + '/config?action=Get&id=' + sSchemeId + '">' +
  260.                 sSchemeName + '</a>'#13#10 + '<td><a href="' + Request.ScriptName +
  261.                 '/config?action=Delete&id=' + sSchemeId + '">Delete</a></tr>'#13#10;
  262.             end;
  263.           ReplaceText := ReplaceText + '</table>'#13#10;
  264.         finally
  265.           slsKeys.Free;
  266.         end;
  267.       end;
  268.   end;
  269. end